unit UVarMono;

interface

uses Variants, UMono, UMonoIntf;

function VarMono: TVarType;
function VarMonoCreate(monoclass: PMonoClass; aDomain: PMonoDomain = nil): Variant; overload;
function VarMonoCreate(monoclass: PMonoClass; const aSignature: string;
  const aParams: array of const; aDomain: PMonoDomain = nil ): Variant; overload;
function V2MonoObject(const V: Variant): PMonoObject;
function MonoObj2V(aObj: PMonoObject): Variant; overload;
procedure MonoObj2V(aObj: PMonoObject; var aResult: TVarData); overload;

function varObject: TVarType;
function V2O(const V: Variant): TObject;
function O2V(O: TObject): Variant;

implementation

uses
  VarUtils, SysUtils, SysConst, TypInfo, Classes;

type
  TMonoVariantType = class(TInvokeableVariantType)
  protected
    function FixupIdent(const AText: string): string; override;
    procedure MonoVarDataCreate(var Dest: TVarData; AObject: PMonoObject);

  public
    procedure Clear(var V: TVarData); override;
    procedure Copy(var Dest: TVarData; const Source: TVarData;
      const Indirect: Boolean); override;
    function DoFunction(var Dest: TVarData; const V: TVarData;
      const Name: string; const Arguments: TVarDataArray): Boolean; override;
    function DoProcedure(const V: TVarData; const Name: string;
      const Arguments: TVarDataArray): Boolean; override;
    function GetProperty(var Dest: TVarData; const V: TVarData;
      const Name: string): Boolean; override;
    function SetProperty(const V: TVarData; const Name: string;
      const Value: TVarData): Boolean; override;
  end;

  IVarMonoObj = interface
  ['{E49FD5C2-8F57-4836-B7DF-AFAAF6AB3B0A}']
    function GetCGHandle: Cardinal;
    function GetMonoObject: PMonoObject;
    function GetRefCount: integer;
    property GCHandle: Cardinal read GetCGHandle;
    property MonoObject: PMonoObject read GetMonoObject;
    property RefCount: Integer read GetRefCount;
  end;

  TVarMonoObj = class(TInterfacedObject, IVarMonoObj)
  private
    FGCHandle: Cardinal;
    function GetCGHandle: Cardinal;
    function GetMonoObject: PMonoObject;
    function GetRefCount: integer;
  public
    constructor Create(aMonoObject: PMonoObject);
    procedure BeforeDestruction; override;
    property GCHandle: Cardinal read GetCGHandle;
    property MonoObject: PMonoObject read GetMonoObject;
    property RefCount: Integer read GetRefCount;
  end;


  TMonoVarData = packed record
    VType: TVarType;
    Reserved1, Reserved2, Reserved3: Word;
    IObject: IVarMonoObj;//cardinal; // pMonoObject;
    Reserved4: LongInt;
  end;

  TDObjVariantType = class(TCustomVariantType)
  public
    procedure Clear(var V: TVarData); override;
    procedure Copy(var Dest: TVarData; const Source: TVarData;
      const Indirect: Boolean); override;
    procedure CastTo(var Dest: TVarData; const Source: TVarData;
      const AVarType: TVarType); override;
  end;

var
  MonoVariantType: TMonoVariantType = nil;
  ObjectVariantType: TDObjVariantType = nil;

function VarMono: TVarType;
begin
  Result := MonoVariantType.VarType;
end;

function VarMonoCreate(monoclass: PMonoClass; aDomain: PMonoDomain = nil): Variant;
var
  lObj: PMonoObject;
begin
  VarClear(Result);
  if Assigned(monoclass) then
  begin
    lObj := MonoJit.CreateMonoObject(monoclass, aDomain);
    MonoVariantType.MonoVarDataCreate(TVarData(Result), lObj);
    // TMonoVarData(Result).VType := VarMono;
    // TMonoVarData(Result).VObject := mono_gchandle_new(lObj, true);
  end;
end;

function VarMonoCreate(monoclass: PMonoClass; const aSignature: string;
  const aParams: array of const; aDomain: PMonoDomain = nil ): Variant;
var
  lObj: PMonoObject;
begin
  VarClear(Result);
  if Assigned(monoclass) then
  begin
    lObj := MonoJit.CreateMonoObject(monoclass, aSignature, aParams, aDomain);
    MonoVariantType.MonoVarDataCreate(TVarData(Result), lObj);
  end;
end;

function V2MonoObject(const V: Variant): PMonoObject;
begin
  result := TMonoVarData(V).IObject.MonoObject;
end;


function MonoObj2V(aObj: PMonoObject): Variant;
begin
  MonoVariantType.MonoVarDataCreate(TVarData(Result), aObj);
  // TMonoVarData(Result).VType := VarMono;
  // TMonoVarData(Result).VObject := mono_gchandle_new(aObj, true);
end;

procedure MonoObj2V(aObj: PMonoObject; var aResult: TVarData);
begin
  MonoVariantType.MonoVarDataCreate(aResult, aObj);
end;

function varObject: TVarType;
begin
  Result := ObjectVariantType.VarType;
end;

function V2O(const V: Variant): TObject;
begin
  Result := TVarData(V).VPointer;
end;

function O2V(O: TObject): Variant;
begin
  TVarData(Result).VType := varObject;
  TVarData(Result).VPointer := O;
end;
{ TMonoVariantType }

procedure TMonoVariantType.Clear(var V: TVarData);
begin
  V.VType := varEmpty;
  TMonoVarData(V).IObject := nil;
end;

procedure TMonoVariantType.Copy(var Dest: TVarData; const Source: TVarData;
  const Indirect: Boolean);
begin
  VarDataClear(Dest);
  Dest.VType := VarMono;
  TMonoVarData(Dest).IObject := TMonoVarData(Source).IObject;
end;


function TMonoVariantType.DoFunction(var Dest: TVarData; const V: TVarData;
  const Name: string; const Arguments: TVarDataArray): Boolean;
var
  obj: PMonoObject;
  m: PMonoMethod;
  lSignatureList: TSignatureList;
begin
  Result := true;
  obj := TMonoVarData(V).IObject.MonoObject;
//  m := MonoJit.FindMonoMethod(mono_object_get_class(obj), Name, '', false);
  MonoJit.GenSignatureList(Arguments, lsignatureList);
  m := MonoJit.FindMonoMethod(mono_object_get_class(obj), Name, lsignatureList);
  if m <> nil then
    MonoJit.CallMonoMethodVar(m, obj, Arguments, Dest, mono_object_get_domain(obj))
  else
    Result := false;
end;

function TMonoVariantType.DoProcedure(const V: TVarData; const Name: string;
  const Arguments: TVarDataArray): Boolean;
var
  obj: PMonoObject;
  m: PMonoMethod;
  lRes: TVarData;
  lSignatureList: TSignatureList;
begin
  Result := true;
  obj := TMonoVarData(V).IObject.MonoObject;
  MonoJit.GenSignatureList(Arguments, lsignatureList);
  m := MonoJit.FindMonoMethod(mono_object_get_class(obj), Name, lsignatureList);
  //m := MonoJit.FindMonoMethod(mono_object_get_class(obj), Name, '', false);

  if m <> nil then
    MonoJit.CallMonoMethodVar(m, obj, Arguments, lRes, mono_object_get_domain(obj))
  else
    Result := false;
end;

function TMonoVariantType.FixupIdent(const AText: string): string;
begin
  Result := AText; // no uppercase
end;

function TMonoVariantType.GetProperty(var Dest: TVarData; const V: TVarData;
  const Name: string): Boolean;
var
  obj: PMonoObject;
  lProp: PMonoProperty;
  mProp: PMonoMethod;
  lArguments: TVarDataArray;
  lName: UTF8String;
  lClass: PMonoClass;
begin
  Result := true;

  obj := TMonoVarData(V).IObject.MonoObject;
  lName := UTF8Encode(Name);
  lClass := mono_object_get_class(obj);
  lProp := MonoJit.FindMonoProperty(lClass, Name);

  if lProp <> nil then
  begin
    mProp := mono_property_get_get_method(lProp);
    if mProp <> nil then
    begin
      SetLength(lArguments, 0);
      MonoJit.CallMonoMethodVar(mProp, obj, lArguments, Dest, mono_object_get_domain(obj));
    end
    else
      Result := false;
  end
  else
    Result := false;
end;

procedure TMonoVariantType.MonoVarDataCreate(var Dest: TVarData;
  AObject: PMonoObject);
var
  iObj: IVarMonoObj;
begin
  VarDataClear(Dest);
  if Assigned(AObject) then
  begin
    TMonoVarData(Dest).VType := VarMono;
    iObj := TVarMonoObj.Create(AObject);
    TVarData(Dest).VPointer := nil;
    TMonoVarData(Dest).IObject := iObj;
  end;
end;

function TMonoVariantType.SetProperty(const V: TVarData; const Name: string;
  const Value: TVarData): Boolean;
var
  obj: PMonoObject;
  lProp: PMonoProperty;
  mProp: PMonoMethod;
  lArguments: TVarDataArray;
  lName: UTF8String;
  lClass: PMonoClass;
  lRes: TVarData;
begin
  Result := true;

  obj := TMonoVarData(V).IObject.MonoObject;
  lName := UTF8Encode(Name);
  lClass := mono_object_get_class(obj);
  lProp := MonoJit.FindMonoProperty(lClass, Name);

  if lProp <> nil then
  begin
    mProp := mono_property_get_set_method(lProp);
    if mProp <> nil then
    begin
      SetLength(lArguments, 1);
      lArguments[0] := Value;
      MonoJit.CallMonoMethodVar(mProp, obj, lArguments, lRes, mono_object_get_domain(obj))
    end
    else
      Result := false;
  end
  else
    Result := false;
end;

{ TDObjVariantType }

procedure TDObjVariantType.CastTo(var Dest: TVarData; const Source: TVarData;
  const AVarType: TVarType);
begin
  Dest.VPointer := Source.VPointer;
end;

procedure TDObjVariantType.Clear(var V: TVarData);
begin
  SimplisticClear(V);
end;

procedure TDObjVariantType.Copy(var Dest: TVarData; const Source: TVarData;
  const Indirect: Boolean);
begin
  SimplisticCopy(Dest, Source, Indirect);
end;

{ TVarMonoObj }

procedure TVarMonoObj.BeforeDestruction;
begin
  inherited;
  if (FGCHandle <> 0)and(assigned(MonoJit))and(MonoJit.Domain <> nil) then
    mono_gchandle_free(FGCHandle);
end;

constructor TVarMonoObj.Create(aMonoObject: PMonoObject);
begin
  inherited Create;
  FGCHandle := mono_gchandle_new(aMonoObject, true);
end;

function TVarMonoObj.GetCGHandle: Cardinal;
begin
  result := FGCHandle;
end;

function TVarMonoObj.GetMonoObject: PMonoObject;
begin
  result := mono_gchandle_get_target(FGCHandle);
end;

function TVarMonoObj.GetRefCount: integer;
begin
  result := FRefCount;
end;

initialization

MonoVariantType := TMonoVariantType.Create;
ObjectVariantType := TDObjVariantType.Create;

finalization

FreeAndNil(MonoVariantType);
FreeAndNil(ObjectVariantType);

end.
